PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/envcalc.com/UWCALC.PAS

Pascal/Delphi Source File | 1991-03-15 | 6.7 KB | 336 lines

{--------------------------------------------------------------}
{ UWCALC.PAS                                                   }
{ COPYRIGHT (C) USERWARE 1991 ALL RIGHTS RESERVED.             }
{ (portions copyright Borland International 1990.)             }
{ USERWARE, 4 FALCON LN E, FAIRPORT NY 14450-3312 USA.         }
{ VOICE: 716-425-3463. CIS: 71540,3660.                        }
{==============================================================}

unit uwcalc;

interface

type
 csstring=string[15];
const
 cserrst:csstring='Error';

const
 csclear  ='C';
 csdecimal='.';
 csplus   ='+';
 csminus  ='-';
 cstimes  ='*';
 csdivide ='÷';
 csequal  ='=';
 csmod    =#15;

 cschgsign='±';
 cspercent='%';

 cseq  ='≈';
 cslt  ='<';
 csgt  ='>';
 cslteq='≤';
 csgteq='≥';
 csnteq='≡';

 csand='&';
 csor ='|';
 csxor='@';

 csnot='!';
 cssqrt='√';
 cssqr='²';

 csshl='«';
 csshr='»';

 csopen ='(';
 csclose=')';

const
 csfalse= 0;
 cstrue =-1; { (not 0)==(-1) }

{}

function calcstr(var result:real; var exp:string):boolean;

type
 opstr=string[2];

procedure opsub(var s:string;this,that:opstr);
procedure stdsub(var s:string);

procedure democalc;

{}

implementation

function calcstr(var result:real; var exp:string):boolean;
type
 tcalcstate=(csfirst,csvalid,cserror);
var
 status:tcalcstate;
 number:csstring;
 sign:char;
 operator:char;
 operand:real;

 procedure clear;
 begin
  status:=csfirst;
  sign:=' ';
  operator:=csequal
 end;

 procedure calckey(key:char);
 var
  r:real;

  procedure error;
  begin
   status:=cserror;
   number:=cserrst;
   sign:=' '
  end;

  procedure setnumber(r:real);
  var
   s:string[63];
  begin
   str(r:0:10,s);
   if (s[1]<>csminus)
    then sign:=' '
    else begin
     delete(s,1,1);
     sign:=csminus
    end;
   if length(s)>1+15+10
    then error
    else begin
     while (s[length(s)]='0') do dec(s[0]);
     if (s[length(s)]='.') then dec(s[0]);
     number:=s
    end;
  end;

  procedure putnumber(var r:real);
  var
   e:integer;
  begin
   val(sign+number,r,e)
  end;

  procedure checkfirst;
  begin
   if (status<>csfirst) then exit;
   status:=csvalid;
   number:='0';
   sign:=' '
  end;

  procedure checkunary;
  var
   k:char;
  begin
   if (status<>csfirst) then exit;

   checkfirst; k:=key; key:=' ';
   case k of
    csminus:
     begin
      sign:=csminus;
      putnumber(operand);
     end;
    csnot:
     begin
      operator:=k;
      status:=csfirst
     end
    else key:=k end
  end;

 begin {calckey}
  key:=upcase(key);
  if (status=cserror) and (key<>csclear) then key:=' ';

  checkunary;

  case key of

   #8,#27: {editing keys}
    begin
     checkfirst;
     if (length(number)=1) then number:='0' else dec(number[0])
    end;

   '0'..'9':
    begin
     checkfirst;
     if (number='0') then number:='';
     number:=number+key
    end;

   csdecimal:
    begin
     checkfirst;
     if (pos(csdecimal,number)=0) then number:=number+csdecimal
    end;

   cschgsign:
    if sign=' ' then sign:=csminus else sign:=' ';
(*
   cssqrt:
    begin
     putnumber(r); setnumber(sqrt(r)); putnumber(operand)
    end;
   cssqr:
    begin
     putnumber(r); setnumber(sqr(r)); putnumber(operand)
    end;
*)
   csplus,csminus,cstimes,csdivide,csequal,cschgsign,cspercent,#13,
   csnot,cssqrt,cssqr,
   csand,csor,csxor,csmod,csshl,csshr,
   cslt,csgt,cseq,cslteq,csgteq,csnteq:
    begin
     if (status=csvalid) then begin
      status:=csfirst;
      putnumber(r);
      if (key=cspercent) then case OPERATOR of
       csplus,csminus  : r:=operand * r / 100;
       cstimes,csdivide: r:=r / 100
      end;
      case OPERATOR of
       csplus  : setnumber(operand+r);
       csminus : setnumber(operand-r);
       cstimes : setnumber(operand*r);
       csdivide: if (r=0) then error else setnumber(operand / r);
       csmod   : if (r=0) then error else setnumber(trunc(operand) mod trunc(r));

       csnot: setnumber(not trunc(r));
       csxor: setnumber(trunc(operand) xor trunc(r));
       csand: setnumber(trunc(operand) and trunc(r));
       csor : setnumber(trunc(operand) or  trunc(r));
(*
       csshl: setnumber(trunc(operand) shl trunc(r));
       csshr: setnumber(trunc(operand) shr trunc(r));
*)
       cslt: if (operand<r) then setnumber(cstrue) else setnumber(csfalse);
       csgt: if (operand>r) then setnumber(cstrue) else setnumber(csfalse);
       cseq: if (operand=r) then setnumber(cstrue) else setnumber(csfalse);
       csnteq: if (operand<>r) then setnumber(cstrue) else setnumber(csfalse);
       cslteq: if (operand<=r) then setnumber(cstrue) else setnumber(csfalse);
       csgteq: if (operand>=r) then setnumber(cstrue) else setnumber(csfalse);
      end
     end;
     OPERATOR:=key;
     putnumber(operand)
    end; { case key of [operators] }

   csclear: clear
  end { case key .. }
 end; {calckey}

var
 v,x:byte;
label
 quit;
begin {calcstr}

 number:=''; operand:=0; clear;
 x:=length(exp);
 v:=0;
 while (v<>x) and (status<>cserror) do begin
  inc(v);
  if (exp[v]=csclose)
   then begin
    calckey(csequal);
    goto quit
   end
   else if (exp[v]=csopen)
    then begin
     delete(exp,1,v);
     if (not calcstr(result,exp))
      then status:=cserror;
     x:=length(exp);
     v:=0
    end
   else calckey(exp[v])
 end;
 quit:
 if (status=cserror)
  then delete(exp,1,v-1)
  else begin
   exp:=sign+number+copy(exp,v+1,255);
   if (sign=' ') then delete(exp,1,1)
  end;
 result:=operand;
 calcstr:=(status<>cserror)
end;

{}

procedure opsub(var s:string;this,that:opstr);
var
 v:byte;
label
 scan;
begin
 scan:
  v:=pos(this,s);
   if (v=0) then EXIT;
  delete(s,v,length(this));
  insert(that,s,v);
 goto scan
end;

procedure stdsub(var s:string);
begin
 opsub(s,'<=',cslteq); opsub(s,'=<',cslteq);
 opsub(s,'>=',csgteq); opsub(s,'=>',csgteq);
 opsub(s,'==',cseq  );
 opsub(s,'!=',csnteq); opsub(s,'=!',csnteq);
 opsub(s,'<>',csnteq);

 opsub(s,'>>',csshr );
 opsub(s,'<<',csshl );
 opsub(s,'\/',cssqrt);
 opsub(s,'^' ,cssqr);

 opsub(s,'/' ,csdivide);
 opsub(s,'\' ,csmod );
 opsub(s,'[' ,csopen);
 opsub(s,']' ,csclose);
end;

{}

procedure democalc;
var
 r:real;
 x,s:string;
begin
 writeln('Available operators include + - / * & | ! < > >= <= == != ( )');
 writeln('Booleans evaluate to 0 (false) or -1 (true)');
 repeat
  write('>'); readln(s); stdsub(s);

  x:=s+csequal; {writeln(':',s);}

  if calcstr(r,x)
   then writeln('=',r,' ',x)
   else writeln(#19,
    copy(s,1,length(s)-length(x)+1),
     #127,
     copy(x,1,pred(length(x)))
    )
 until (s='')
end;

end.